home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_guile.idb / usr / freeware / share / guile / 1.3 / ice-9 / expect.scm.z / expect.scm
Encoding:
Text File  |  1999-04-16  |  4.2 KB  |  140 lines
  1. ;;; installed-scm-file
  2.  
  3. ;;;;     Copyright (C) 1996, 1998 Free Software Foundation, Inc.
  4. ;;;; 
  5. ;;;; This program is free software; you can redistribute it and/or modify
  6. ;;;; it under the terms of the GNU General Public License as published by
  7. ;;;; the Free Software Foundation; either version 2, or (at your option)
  8. ;;;; any later version.
  9. ;;;; 
  10. ;;;; This program is distributed in the hope that it will be useful,
  11. ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12. ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13. ;;;; GNU General Public License for more details.
  14. ;;;; 
  15. ;;;; You should have received a copy of the GNU General Public License
  16. ;;;; along with this software; see the file COPYING.  If not, write to
  17. ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  18. ;;;; Boston, MA 02111-1307 USA
  19. ;;;; 
  20.  
  21.  
  22. (define-module (ice-9 expect) :use-module (ice-9 regex))
  23.  
  24. ;;; Expect: a macro for selecting actions based on what it reads from a port.
  25. ;;; The idea is from Don Libes' expect based on Tcl.
  26. ;;; This version by Gary Houston incorporating ideas from Aubrey Jaffer.
  27.  
  28.  
  29. (define-public expect-port #f)
  30. (define-public expect-timeout #f)
  31. (define-public expect-timeout-proc #f)
  32. (define-public expect-eof-proc #f)
  33. (define-public expect-char-proc #f)
  34.  
  35. ;;; expect: each test is a procedure which is applied to the accumulating
  36. ;;; string.
  37. (defmacro-public expect clauses
  38.   (let ((s (gentemp))
  39.     (c (gentemp))
  40.     (port (gentemp))
  41.     (timeout (gentemp)))
  42.     `(let ((,s "")
  43.        (,port (or expect-port (current-input-port)))
  44.        ;; when timeout occurs, in floating point seconds.
  45.        (,timeout (if expect-timeout
  46.              (let* ((secs-usecs (gettimeofday)))
  47.                (+ (car secs-usecs)
  48.                   expect-timeout
  49.                   (/ (cdr secs-usecs)
  50.                  1000000))) ; one million.
  51.              #f)))
  52.        (let next-char ()
  53.      (if (and expect-timeout
  54.           (or (>= (get-internal-real-time) ,timeout)
  55.               (and (not (char-ready? ,port))
  56.                (not (expect-select ,port ,timeout)))))
  57.          (if expect-timeout-proc
  58.          (expect-timeout-proc ,s)
  59.          #f)
  60.          (let ((,c (read-char ,port)))
  61.            (if expect-char-proc
  62.            (expect-char-proc ,c))
  63.            (cond ((eof-object? ,c)
  64.               (if expect-eof-proc
  65.               (expect-eof-proc ,s)
  66.               #f))
  67.              (else
  68.               (set! ,s (string-append ,s (string ,c)))
  69.               (cond
  70.                ,@(let next-expr ((tests (map car clauses))
  71.                      (exprs (map cdr clauses))
  72.                      (body '()))
  73.                (cond
  74.                 ((null? tests)
  75.                  (reverse body))
  76.                 (else
  77.                  (next-expr
  78.                   (cdr tests)
  79.                   (cdr exprs)
  80.                   (cons
  81.                    `((,(car tests) ,s)
  82.                  ,@(cond ((null? (car exprs))
  83.                       '())
  84.                      ((eq? (caar exprs) '=>)
  85.                       (if (not (= (length (car exprs))
  86.                               2))
  87.                           (scm-error 'misc-error
  88.                              "expect"
  89.                              "bad recipient: %S"
  90.                              (list (car exprs))
  91.                              #f)
  92.                           `((apply ,(cadar exprs)
  93.                                (,(car tests) ,s)))))
  94.                      (else 
  95.                       (car exprs))))
  96.                    body)))))
  97.                (else (next-char)))))))))))
  98.  
  99. ;;; the regexec front-end to expect:
  100. ;;; each test must evaluate to a regular expression.
  101. (defmacro-public expect-strings clauses
  102.   `(let ,@(let next-test ((tests (map car clauses))
  103.               (exprs (map cdr clauses))
  104.               (defs '())
  105.               (body '()))
  106.         (cond ((null? tests)
  107.            (list (reverse defs) `(expect ,@(reverse body))))
  108.           (else
  109.            (let ((rxname (gentemp)))
  110.              (next-test (cdr tests)
  111.                 (cdr exprs)
  112.                 (cons `(,rxname (make-regexp ,(car tests)
  113.                                  regexp/newline))
  114.                       defs)
  115.                 (cons `((lambda (s)
  116.                       (expect-regexec ,rxname s))
  117.                     ,@(car exprs))
  118.                       body))))))))
  119.  
  120. ;;; simplified select: returns #t if input is waiting or #f if timed out.
  121. ;;; timeout is an absolute time in floating point seconds.
  122. (define-public (expect-select port timeout)
  123.   (let* ((secs-usecs (gettimeofday))
  124.      (relative (- timeout 
  125.               (car secs-usecs)
  126.               (/ (cdr secs-usecs)
  127.              1000000))))    ; one million.
  128.     (and (> relative 0)
  129.      (pair? (car (select (list port) '() '()
  130.                  relative))))))
  131.  
  132. ;;; convert a match object to a list of strings, for the => syntax.
  133. (define-public (expect-regexec rx s)
  134.   (let ((match (regexp-exec rx s)))
  135.     (if match
  136.     (do ((i (- (match:count match) 1) (- i 1))
  137.          (result '() (cons (match:substring match i) result)))
  138.         ((< i 0) result))
  139.     #f)))
  140.